home *** CD-ROM | disk | FTP | other *** search
/ io Programmo 37 / IOPROG_37.ISO / SOFT / Multilizer.exe / disk1 / data1.cab / data1 / [Group9]VCL Source Standard / ivdbmlct.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1999-08-12  |  46.2 KB  |  1,816 lines
  1. unit IvDBMlCt;
  2.  
  3. {$I IVMULTI.INC}
  4.  
  5. interface
  6.  
  7. uses
  8. {$IFDEF WIN32}
  9.   Windows,
  10. {$ELSE}
  11.   WinTypes, WinProcs, DBLookup,
  12. {$ENDIF}
  13.   Messages, Forms, Graphics, Classes, Controls, DB, DBCtrls, IvMLCtrl;
  14.  
  15. type
  16.   TIvDBText = class(TDBText)
  17. {$IFNDEF IVBIDI}
  18.   private
  19.   {$IFDEF WIN32}
  20.     {$IFNDEF VER110}
  21.     procedure DoDrawText(var rect: TRect; flags: Integer);
  22.     {$ENDIF}
  23.   {$ENDIF}
  24.  
  25.   protected
  26.     FLocale: Integer;
  27.  
  28.     procedure SetLocale(value: Integer);
  29.  
  30.   {$IFDEF WIN32}
  31.     {$IFDEF VER110}
  32.     procedure DoDrawText(var rect: TRect; flags: Word); override;
  33.     {$ENDIF}
  34.     procedure Paint; override;
  35.   {$ENDIF}
  36.  
  37.   public
  38.     constructor Create(owner: TComponent); override;
  39.  
  40.   published
  41.     property Locale: Integer read FLocale write SetLocale stored False;
  42. {$ENDIF}
  43.   end;
  44.  
  45.   TIvDBRadioGroup = class(TDBRadioGroup)
  46. {$IFNDEF IVBIDI}
  47.   protected
  48.     FLocale: Integer;
  49.  
  50.     procedure SetLocale(value: Integer);
  51.  
  52.   {$IFDEF WIN32}
  53.     procedure Paint; override;
  54.   {$ENDIF}
  55.  
  56.   public
  57.     constructor Create(owner: TComponent); override;
  58.  
  59.   published
  60.     property Locale: Integer read FLocale write SetLocale stored False;
  61. {$ENDIF}
  62.   end;
  63.  
  64.   TIvDBListBox = class(TDBListBox)
  65. {$IFNDEF IVBIDI}
  66.   private
  67.     FLocale: Integer;
  68.  
  69.     procedure SetLocale(value: Integer);
  70.  
  71.   protected
  72.     procedure CreateParams(var Params: TCreateParams); override;
  73.  
  74.   public
  75.     constructor Create(owner: TComponent); override;
  76.  
  77.   published
  78.     property Locale: Integer read FLocale write SetLocale stored False;
  79. {$ENDIF}
  80.   end;
  81.  
  82.   TIvDBComboBox = class(TDBComboBox)
  83. {$IFNDEF IVBIDI}
  84.   private
  85.     FLocale: Integer;
  86.  
  87.     procedure SetLocale(value: Integer);
  88.  
  89.   protected
  90.     procedure CreateParams(var Params: TCreateParams); override;
  91.  
  92.   public
  93.     constructor Create(owner: TComponent); override;
  94.  
  95.   published
  96.     property Locale: Integer read FLocale write SetLocale stored False;
  97. {$ENDIF}
  98.   end;
  99.  
  100. {$IFDEF WIN32}
  101. {$IFDEF IVBIDI}
  102.   TIvDBLookupControl = class(TDBLookupControl)
  103.   end;
  104. {$ELSE}
  105.   TIvDBLookupControl = class;
  106.  
  107.   TIvDataSourceLink = class(TDataLink)
  108.   private
  109.     FDBLookupControl: TIvDBLookupControl;
  110.  
  111.   protected
  112.     procedure FocusControl(Field: TFieldRef); override;
  113.     procedure ActiveChanged; override;
  114.     procedure RecordChanged(Field: TField); override;
  115.   end;
  116.  
  117.   TIvListSourceLink = class(TDataLink)
  118.   private
  119.     FDBLookupControl: TIvDBLookupControl;
  120.  
  121.   protected
  122.     procedure ActiveChanged; override;
  123.     procedure DataSetChanged; override;
  124.   end;
  125.  
  126.   TIvDBLookupControl = class(TCustomControl)
  127.   private
  128.     FLocale: Integer;
  129.     FLookupSource: TDataSource;
  130.     FDataLink: TIvDataSourceLink;
  131.     FListLink: TIvListSourceLink;
  132.     FDataFieldName: string;
  133.     FKeyFieldName: string;
  134.     FListFieldName: string;
  135.     FListFieldIndex: Integer;
  136.     FDataField: TField;
  137.     FMasterField: TField;
  138.     FKeyField: TField;
  139.     FListField: TField;
  140.     FListFields: TList;
  141.     FKeyValue: Variant;
  142.     FSearchText: string;
  143.     FLookupMode: Boolean;
  144.     FListActive: Boolean;
  145.     FFocused: Boolean;
  146.  
  147.     procedure SetLocale(value: Integer);
  148.     function CanModify: Boolean;
  149.     procedure CheckNotCircular;
  150.     procedure CheckNotLookup;
  151.     procedure DataLinkActiveChanged;
  152.     procedure DataLinkRecordChanged(Field: TField);
  153.     function GetBorderSize: Integer;
  154.     function GetDataSource: TDataSource;
  155.     function GetKeyFieldName: string;
  156.     function GetListSource: TDataSource;
  157.     function GetReadOnly: Boolean;
  158.     function GetTextHeight: Integer;
  159.     procedure KeyValueChanged; virtual;
  160.     procedure ListLinkActiveChanged; virtual;
  161.     procedure ListLinkDataChanged; virtual;
  162.     function LocateKey: Boolean;
  163.     procedure ProcessSearchKey(Key: Char);
  164.     procedure SelectKeyValue(const Value: Variant);
  165.     procedure SetDataFieldName(const Value: string);
  166.     procedure SetDataSource(Value: TDataSource);
  167.     procedure SetKeyFieldName(const Value: string);
  168.     procedure SetKeyValue(const Value: Variant);
  169.     procedure SetListFieldName(const Value: string);
  170.     procedure SetListSource(Value: TDataSource);
  171.     procedure SetLookupMode(Value: Boolean);
  172.     procedure SetReadOnly(Value: Boolean);
  173.     procedure WMGetDlgCode(var Message: TMessage); message WM_GETDLGCODE;
  174.     procedure WMKillFocus(var Message: TMessage); message WM_KILLFOCUS;
  175.     procedure WMSetFocus(var Message: TMessage); message WM_SETFOCUS;
  176.  
  177.   protected
  178.     procedure Notification(AComponent: TComponent;
  179.       Operation: TOperation); override;
  180.     property DataField: string read FDataFieldName write SetDataFieldName;
  181.     property DataSource: TDataSource read GetDataSource write SetDataSource;
  182.     property KeyField: string read GetKeyFieldName write SetKeyFieldName;
  183.     property KeyValue: Variant read FKeyValue write SetKeyValue;
  184.     property ListField: string read FListFieldName write SetListFieldName;
  185.     property ListFieldIndex: Integer read FListFieldIndex write FListFieldIndex default 0;
  186.     property ListSource: TDataSource read GetListSource write SetListSource;
  187.     property ParentColor default False;
  188.     property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;
  189.     property TabStop default True;
  190.  
  191.     procedure PaintItem(Canvas: TCanvas; const str: String; rect: TRect; x, y: Integer);
  192.  
  193.   public
  194.     constructor Create(AOwner: TComponent); override;
  195.     destructor Destroy; override;
  196.     property Field: TField read FDataField;
  197.  
  198.   published
  199.     property Locale: Integer read FLocale write SetLocale stored False;
  200.   end;
  201. {$ENDIF}
  202.  
  203. {$IFDEF IVBIDI}
  204.   TIvDBLookupListBox = class(TDBLookupListBox)
  205.   end;
  206. {$ELSE}
  207.   TIvDBLookupListBox = class(TIvDBLookupControl)
  208.   private
  209.     FRecordIndex: Integer;
  210.     FRecordCount: Integer;
  211.     FRowCount: Integer;
  212.     FBorderStyle: TBorderStyle;
  213.     FPopup: Boolean;
  214.     FKeySelected: Boolean;
  215.     FTracking: Boolean;
  216.     FTimerActive: Boolean;
  217.     FLockPosition: Boolean;
  218.     FMousePos: Integer;
  219.     FSelectedItem: string;
  220.  
  221.     function GetKeyIndex: Integer;
  222.     procedure KeyValueChanged; override;
  223.     procedure ListLinkActiveChanged; override;
  224.     procedure ListLinkDataChanged; override;
  225.     procedure SelectCurrent;
  226.     procedure SelectItemAt(X, Y: Integer);
  227.     procedure SetBorderStyle(Value: TBorderStyle);
  228.     procedure SetRowCount(Value: Integer);
  229.     procedure StopTimer;
  230.     procedure StopTracking;
  231.     procedure TimerScroll;
  232.     procedure UpdateScrollBar;
  233.     procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
  234.     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  235.     procedure WMCancelMode(var Message: TMessage); message WM_CANCELMODE;
  236.     procedure WMTimer(var Message: TMessage); message WM_TIMER;
  237.     procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL;
  238.  
  239.   protected
  240.     procedure CreateParams(var Params: TCreateParams); override;
  241.     procedure CreateWnd; override;
  242.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  243.     procedure KeyPress(var Key: Char); override;
  244.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
  245.       X, Y: Integer); override;
  246.     procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
  247.     procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
  248.       X, Y: Integer); override;
  249.     procedure Paint; override;
  250.     procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
  251.  
  252.   public
  253.     constructor Create(owner: TComponent); override;
  254.  
  255.     property KeyValue;
  256.     property SelectedItem: string read FSelectedItem;
  257.  
  258.   published
  259.     property Align;
  260.     property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
  261.     property Color;
  262.     property Ctl3D;
  263.     property DataField;
  264.     property DataSource;
  265.     property DragCursor;
  266.     property DragMode;
  267.     property Enabled;
  268.     property Font;
  269. {$IFDEF IVWIDE}
  270.     property ImeMode;
  271.     property ImeName;
  272. {$ENDIF}
  273.     property KeyField;
  274.     property ListField;
  275.     property ListFieldIndex;
  276.     property ListSource;
  277.     property ParentColor;
  278.     property ParentCtl3D;
  279.     property ParentFont;
  280.     property ParentShowHint;
  281.     property PopupMenu;
  282.     property ReadOnly;
  283.     property RowCount: Integer read FRowCount write SetRowCount stored False;
  284.     property ShowHint;
  285.     property TabOrder;
  286.     property TabStop;
  287.     property Visible;
  288.     property OnClick;
  289.     property OnDblClick;
  290.     property OnDragDrop;
  291.     property OnDragOver;
  292.     property OnEndDrag;
  293.     property OnEnter;
  294.     property OnExit;
  295.     property OnKeyDown;
  296.     property OnKeyPress;
  297.     property OnKeyUp;
  298.     property OnMouseDown;
  299.     property OnMouseMove;
  300.     property OnMouseUp;
  301.     property OnStartDrag;
  302.   end;
  303. {$ENDIF}
  304.  
  305. {$IFDEF IVBIDI}
  306.   TIvDBLookupComboBox = class(TDBLookupComboBox)
  307.   end;
  308. {$ELSE}
  309.   TIvPopupDataList = class(TIvDBLookupListBox)
  310.   private
  311.     procedure WMMouseActivate(var Message: TMessage); message WM_MOUSEACTIVATE;
  312.   protected
  313.     procedure CreateParams(var Params: TCreateParams); override;
  314.   public
  315.     constructor Create(AOwner: TComponent); override;
  316.   end;
  317.  
  318.   TIvDropDownAlign = (daLeft, daRight, daCenter);
  319.  
  320.   TIvDBLookupComboBox = class(TIvDBLookupControl)
  321.   private
  322.     FDataList: TIvPopupDataList;
  323.     FButtonWidth: Integer;
  324.     FText: string;
  325.     FDropDownRows: Integer;
  326.     FDropDownWidth: Integer;
  327.     FDropDownAlign: TIvDropDownAlign;
  328.     FListVisible: Boolean;
  329.     FPressed: Boolean;
  330.     FTracking: Boolean;
  331.     FAlignment: TAlignment;
  332.     FLookupMode: Boolean;
  333.     FOnDropDown: TNotifyEvent;
  334.     FOnCloseUp: TNotifyEvent;
  335.  
  336.     procedure KeyValueChanged; override;
  337.     procedure ListLinkActiveChanged; override;
  338.     procedure ListMouseUp(Sender: TObject; Button: TMouseButton;
  339.       Shift: TShiftState; X, Y: Integer);
  340.     procedure StopTracking;
  341.     procedure TrackButton(X, Y: Integer);
  342.     procedure CMCancelMode(var Message: TCMCancelMode); message CM_CANCELMODE;
  343.     procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
  344.     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  345.     procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK;
  346.     procedure WMCancelMode(var Message: TMessage); message WM_CANCELMODE;
  347.     procedure WMKillFocus(var Message: TWMKillFocus); message WM_KILLFOCUS;
  348.  
  349.   protected
  350.     procedure CreateParams(var Params: TCreateParams); override;
  351.     procedure Paint; override;
  352.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  353.     procedure KeyPress(var Key: Char); override;
  354.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
  355.       X, Y: Integer); override;
  356.     procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
  357.     procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
  358.       X, Y: Integer); override;
  359.     procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
  360.  
  361.   public
  362.     constructor Create(AOwner: TComponent); override;
  363.  
  364.     procedure CloseUp(Accept: Boolean);
  365.     procedure DropDown;
  366.  
  367.     property KeyValue;
  368.     property ListVisible: Boolean read FListVisible;
  369.     property Text: string read FText;
  370.  
  371.   published
  372.     property Color;
  373.     property Ctl3D;
  374.     property DataField;
  375.     property DataSource;
  376.     property DragCursor;
  377.     property DragMode;
  378.     property DropDownAlign: TIvDropDownAlign read FDropDownAlign write FDropDownAlign default daLeft;
  379.     property DropDownRows: Integer read FDropDownRows write FDropDownRows default 7;
  380.     property DropDownWidth: Integer read FDropDownWidth write FDropDownWidth default 0;
  381.     property Enabled;
  382.     property Font;
  383. {$IFDEF IVWIDE}
  384.     property ImeMode;
  385.     property ImeName;
  386. {$ENDIF}
  387.     property KeyField;
  388.     property ListField;
  389.     property ListFieldIndex;
  390.     property ListSource;
  391.     property ParentColor;
  392.     property ParentCtl3D;
  393.     property ParentFont;
  394.     property ParentShowHint;
  395.     property PopupMenu;
  396.     property ReadOnly;
  397.     property ShowHint;
  398.     property TabOrder;
  399.     property TabStop;
  400.     property Visible;
  401.     property OnClick;
  402.     property OnCloseUp: TNotifyEvent read FOnCloseUp write FOnCloseUp;
  403.     property OnDragDrop;
  404.     property OnDragOver;
  405.     property OnDropDown: TNotifyEvent read FOnDropDown write FOnDropDown;
  406.     property OnEndDrag;
  407.     property OnEnter;
  408.     property OnExit;
  409.     property OnKeyDown;
  410.     property OnKeyPress;
  411.     property OnKeyUp;
  412.     property OnMouseDown;
  413.     property OnMouseMove;
  414.     property OnMouseUp;
  415.     property OnStartDrag;
  416.   end;
  417. {$ENDIF}
  418. {$ELSE}
  419.   TIvDBLookupListBox = class(TDBLookupList)
  420.   end;
  421.  
  422.   TIvDBLookupComboBox = class(TDBLookupCombo)
  423.   end;
  424. {$ENDIF}
  425.  
  426. implementation
  427.  
  428. {$IFNDEF IVBIDI}
  429. uses
  430.   SysUtils,
  431.   DBConsts, IvDictio, IvMulti;
  432.  
  433. { TIvDBText }
  434.  
  435. constructor TIvDBText.Create(owner: TComponent);
  436. begin
  437.   inherited Create(owner);
  438.   FLocale := 0;
  439. end;
  440.  
  441. procedure TIvDBText.SetLocale(value: Integer);
  442. begin
  443.   if value <> FLocale then
  444.   begin
  445.     FLocale := value;
  446.     Invalidate;
  447.   end;
  448. end;
  449.  
  450. {$IFDEF WIN32}
  451.   {$IFDEF VER110}
  452. procedure TIvDBText.DoDrawText(var rect: TRect; flags: Word);
  453.   {$ELSE}
  454. procedure TIvDBText.DoDrawText(var rect: TRect; flags: Integer);
  455.   {$ENDIF}
  456. var
  457.   Text: String;
  458. begin
  459.   Text := GetLabelText;
  460.   if (Flags and DT_CALCRECT <> 0) and ((Text = '') or ShowAccelChar and
  461.     (Text[1] = '&') and (Text[2] = #0)) then Text := Text + ' ';
  462.   if not ShowAccelChar then
  463.     Flags := Flags or DT_NOPREFIX;
  464.   Canvas.Font := Font;
  465.  
  466.  
  467. {$IFDEF IVWIDE}
  468.   if not Enabled then
  469.   begin
  470.     OffsetRect(Rect, 1, 1);
  471.     Canvas.Font.Color := clBtnHighlight;
  472.     DrawTextEx(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags, nil);
  473.     OffsetRect(Rect, -1, -1);
  474.     Canvas.Font.Color := clBtnShadow;
  475.     DrawTextEx(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags, nil);
  476.   end
  477.   else
  478.     DrawTextEx(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags, nil);
  479. {$ELSE}
  480.   if not Enabled then
  481.     Canvas.Font.Color := clGrayText;
  482.   DrawTextEx(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags, nil);
  483. {$ENDIF}
  484. end;
  485.  
  486. procedure TIvDBText.Paint;
  487. const
  488.   Alignments: array[TAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER);
  489.   BidiAlignments: array[TAlignment] of Word = (DT_RIGHT, DT_LEFT, DT_CENTER);
  490.   WordWraps: array[Boolean] of Word = (0, DT_WORDBREAK);
  491. var
  492.   Rect: TRect;
  493.   DrawStyle: Integer;
  494. begin
  495.   with Canvas do
  496.   begin
  497.     if not Transparent then
  498.     begin
  499.       Brush.Color := Self.Color;
  500.       Brush.Style := bsSolid;
  501.       FillRect(ClientRect);
  502.     end;
  503.     Brush.Style := bsClear;
  504.     Rect := ClientRect;
  505.     DrawStyle := DT_EXPANDTABS or WordWraps[WordWrap];
  506.       DrawStyle := DrawStyle or Alignments[Alignment];
  507.     DoDrawText(Rect, DrawStyle);
  508.   end;
  509. end;
  510. {$ENDIF}
  511.  
  512.  
  513. { TIvDBRadioGroup }
  514.  
  515. constructor TIvDBRadioGroup.Create(owner: TComponent);
  516. begin
  517.   inherited Create(owner);
  518.   FLocale := 0;
  519. end;
  520.  
  521. procedure TIvDBRadioGroup.SetLocale(value: Integer);
  522. begin
  523.   if FLocale <> Value then
  524.   begin
  525.     FLocale := Value;
  526.     Invalidate;
  527.   end;
  528. end;
  529.  
  530. {$IFDEF WIN32}
  531. procedure TIvDBRadioGroup.Paint;
  532. var
  533.   H: Integer;
  534.   R: TRect;
  535. begin
  536.   with Canvas do
  537.   begin
  538.     Font := Self.Font;
  539.     H := TextHeight('0');
  540.     R := Rect(0, H div 2 - 1, Width, Height);
  541.     if Ctl3D then
  542.     begin
  543.       Inc(R.Left);
  544.       Inc(R.Top);
  545.       Brush.Color := clBtnHighlight;
  546.       FrameRect(R);
  547.       OffsetRect(R, -1, -1);
  548.       Brush.Color := clBtnShadow;
  549.     end else
  550.       Brush.Color := clWindowFrame;
  551.     FrameRect(R);
  552.     if Text <> '' then
  553.     begin
  554.       R := Rect(8, 0, Width - 16, H);
  555.       DrawText(
  556.         Handle,
  557.         PChar(Text),
  558.         Length(Text),
  559.         R,
  560.         DT_LEFT or DT_SINGLELINE or DT_CALCRECT);
  561.       Brush.Color := Color;
  562.  
  563.       DrawText(
  564.         Handle,
  565.         PChar(Text),
  566.         Length(Text),
  567.         R,
  568.         DT_LEFT or DT_SINGLELINE);
  569.     end;
  570.   end;
  571. end;
  572. {$ENDIF}
  573.  
  574. { TIvDBListBox }
  575.  
  576. constructor TIvDBListBox.Create(owner: TComponent);
  577. begin
  578.   inherited Create(owner);
  579.   FLocale := 0;
  580. end;
  581.  
  582. procedure TIvDBListBox.SetLocale(value: Integer);
  583. begin
  584.   if value <> FLocale then
  585.   begin
  586.     FLocale := value;
  587.   end;
  588. end;
  589.  
  590. procedure TIvDBListBox.CreateParams(var Params: TCreateParams);
  591. begin
  592.   inherited CreateParams(params);
  593. end;
  594.  
  595.  
  596. { TIvDBComboBox }
  597.  
  598. constructor TIvDBComboBox.Create(owner: TComponent);
  599. begin
  600.   inherited Create(owner);
  601.   FLocale := 0;
  602. end;
  603.  
  604. procedure TIvDBComboBox.SetLocale(value: Integer);
  605. begin
  606.   if value <> FLocale then
  607.   begin
  608.     FLocale := value;
  609.   end;
  610. end;
  611.  
  612. procedure TIvDBComboBox.CreateParams(var Params: TCreateParams);
  613. begin
  614.   inherited CreateParams(params);
  615. end;
  616.  
  617.  
  618. {$IFDEF WIN32}
  619. { TIvDataSourceLink }
  620.  
  621. procedure TIvDataSourceLink.ActiveChanged;
  622. begin
  623.   if FDBLookupControl <> nil then
  624.     FDBLookupControl.DataLinkActiveChanged;
  625. end;
  626.  
  627. procedure TIvDataSourceLink.RecordChanged(Field: TField);
  628. begin
  629.   if FDBLookupControl <> nil then
  630.     FDBLookupControl.DataLinkRecordChanged(Field);
  631. end;
  632.  
  633. procedure TIvDataSourceLink.FocusControl(Field: TFieldRef);
  634. begin
  635.   if (Field^ <> nil) and (Field^ = FDBLookupControl.Field) and
  636.     (FDBLookupControl <> nil) and FDBLookupControl.CanFocus then
  637.   begin
  638.     Field^ := nil;
  639.     FDBLookupControl.SetFocus;
  640.   end;
  641. end;
  642.  
  643.  
  644. { TIvListSourceLink }
  645.  
  646. procedure TIvListSourceLink.ActiveChanged;
  647. begin
  648.   if FDBLookupControl <> nil then
  649.     FDBLookupControl.ListLinkActiveChanged;
  650. end;
  651.  
  652. procedure TIvListSourceLink.DataSetChanged;
  653. begin
  654.   if FDBLookupControl <> nil then
  655.     FDBLookupControl.ListLinkDataChanged;
  656. end;
  657.  
  658.  
  659. { TIvDBLookupControl }
  660.  
  661. function VarEquals(const V1, V2: Variant): Boolean;
  662. begin
  663.   Result := False;
  664.   try
  665.     Result := V1 = V2;
  666.   except
  667.   end;
  668. end;
  669.  
  670. var
  671.   SearchTickCount: Integer = 0;
  672.  
  673. constructor TIvDBLookupControl.Create(AOwner: TComponent);
  674. begin
  675.   inherited Create(AOwner);
  676.   FLocale := 0;
  677.   if NewStyleControls then
  678.     ControlStyle := [csOpaque] else
  679.     ControlStyle := [csOpaque, csFramed];
  680.   ParentColor := False;
  681.   TabStop := True;
  682.   FLookupSource := TDataSource.Create(Self);
  683.   FDataLink := TIvDataSourceLink.Create;
  684.   FDataLink.FDBLookupControl := Self;
  685.   FListLink := TIvListSourceLink.Create;
  686.   FListLink.FDBLookupControl := Self;
  687.   FListFields := TList.Create;
  688.   FKeyValue := Null;
  689. end;
  690.  
  691. destructor TIvDBLookupControl.Destroy;
  692. begin
  693.   FListFields.Free;
  694.   FListLink.FDBLookupControl := nil;
  695.   FListLink.Free;
  696.   FDataLink.FDBLookupControl := nil;
  697.   FDataLink.Free;
  698.   inherited Destroy;
  699. end;
  700.  
  701. procedure TIvDBLookupControl.PaintItem(
  702.   Canvas: TCanvas;
  703.   const str: String;
  704.   rect: TRect;
  705.   x, y: Integer);
  706. var
  707.   flags: Integer;
  708. begin
  709.     Flags := DT_LEFT;
  710.   Canvas.Pen.Style := psClear;
  711.   Canvas.Rectangle(rect.Left, rect.Top, rect.Right + 1, rect.Bottom + 1);
  712.   Inc(rect.Left, x);
  713.   Inc(rect.Top, y);
  714.   DrawTextEx(Canvas.Handle, PChar(str), Length(str), rect, flags, nil);
  715. end;
  716.  
  717. procedure TIvDBLookupControl.SetLocale(value: Integer);
  718. begin
  719.   if value <> FLocale then
  720.   begin
  721.     FLocale := value;
  722.   end;
  723. end;
  724.  
  725. function TIvDBLookupControl.CanModify: Boolean;
  726. begin
  727.   Result := FListActive and not ReadOnly and ((FDataLink.DataSource = nil) or
  728.     (FMasterField <> nil) and FMasterField.CanModify);
  729. end;
  730.  
  731. procedure TIvDBLookupControl.CheckNotCircular;
  732. begin
  733.   if FDataLink.Active and FDataLink.DataSet.IsLinkedTo(ListSource) then
  734. {$IFDEF IVWIDE}
  735.     DatabaseError(SCircularDataLink);
  736. {$ELSE}
  737.     DatabaseError(LoadStr(SCircularDataLink));
  738. {$ENDIF}
  739.   if FListLink.Active and FListLink.DataSet.IsLinkedTo(DataSource) then
  740. {$IFDEF IVWIDE}
  741.     DatabaseError(SCircularDataLink);
  742. {$ELSE}
  743.     DatabaseError(LoadStr(SCircularDataLink));
  744. {$ENDIF}
  745. end;
  746.  
  747. procedure TIvDBLookupControl.CheckNotLookup;
  748. begin
  749.   if FLookupMode then
  750. {$IFDEF IVWIDE}
  751.     DatabaseError(SPropDefByLookup);
  752. {$ELSE}
  753.     DatabaseError(LoadStr(SPropDefByLookup));
  754. {$ENDIF}
  755.   if FDataLink.DataSourceFixed then
  756. {$IFDEF IVWIDE}
  757.     DatabaseError(SDataSourceFixed);
  758. {$ELSE}
  759.     DatabaseError(LoadStr(SPropDefByLookup));
  760. {$ENDIF}
  761. end;
  762.  
  763. procedure TIvDBLookupControl.DataLinkActiveChanged;
  764. begin
  765.   FDataField := nil;
  766.   FMasterField := nil;
  767.   if FDataLink.Active and (FDataFieldName <> '') then
  768.   begin
  769.     CheckNotCircular;
  770. {$IFDEF IVWIDE}
  771.     FDataField := GetFieldProperty(FDataLink.DataSet, Self, FDataFieldName);
  772. {$ELSE}
  773.     FDataField := FDataLink.DataSet.FieldByName(FDataFieldName);
  774. {$ENDIF}
  775.     FMasterField := FDataField;
  776.   end;
  777.   SetLookupMode((FDataField <> nil) and (FDataField.FieldKind = fkLookup));
  778.   DataLinkRecordChanged(nil);
  779. end;
  780.  
  781. procedure TIvDBLookupControl.DataLinkRecordChanged(Field: TField);
  782. begin
  783.   if (Field = nil) or (Field = FMasterField) then
  784.     if FMasterField <> nil then
  785.       SetKeyValue(FMasterField.Value) else
  786.       SetKeyValue(Null);
  787. end;
  788.  
  789. function TIvDBLookupControl.GetBorderSize: Integer;
  790. var
  791.   Params: TCreateParams;
  792.   R: TRect;
  793. begin
  794.   CreateParams(Params);
  795.   SetRect(R, 0, 0, 0, 0);
  796.   AdjustWindowRectEx(R, Params.Style, False, Params.ExStyle);
  797.   Result := R.Bottom - R.Top;
  798. end;
  799.  
  800. function TIvDBLookupControl.GetDataSource: TDataSource;
  801. begin
  802.   Result := FDataLink.DataSource;
  803. end;
  804.  
  805. function TIvDBLookupControl.GetKeyFieldName: string;
  806. begin
  807.   if FLookupMode then Result := '' else Result := FKeyFieldName;
  808. end;
  809.  
  810. function TIvDBLookupControl.GetListSource: TDataSource;
  811. begin
  812.   if FLookupMode then Result := nil else Result := FListLink.DataSource;
  813. end;
  814.  
  815. function TIvDBLookupControl.GetReadOnly: Boolean;
  816. begin
  817.   Result := FDataLink.ReadOnly;
  818. end;
  819.  
  820. function TIvDBLookupControl.GetTextHeight: Integer;
  821. var
  822.   DC: HDC;
  823.   SaveFont: HFont;
  824.   Metrics: TTextMetric;
  825. begin
  826.   DC := GetDC(0);
  827.   SaveFont := SelectObject(DC, Font.Handle);
  828.   GetTextMetrics(DC, Metrics);
  829.   SelectObject(DC, SaveFont);
  830.   ReleaseDC(0, DC);
  831.   Result := Metrics.tmHeight;
  832. end;
  833.  
  834. procedure TIvDBLookupControl.KeyValueChanged;
  835. begin
  836. end;
  837.  
  838. procedure TIvDBLookupControl.ListLinkActiveChanged;
  839. var
  840.   DataSet: TDataSet;
  841.   ResultField: TField;
  842. begin
  843.   FListActive := False;
  844.   FKeyField := nil;
  845.   FListField := nil;
  846.   FListFields.Clear;
  847.   if FListLink.Active and (FKeyFieldName <> '') then
  848.   begin
  849.     CheckNotCircular;
  850.     DataSet := FListLink.DataSet;
  851. {$IFDEF IVWIDE}
  852.     FKeyField := GetFieldProperty(DataSet, Self, FKeyFieldName);
  853. {$ELSE}
  854.     FKeyField := DataSet.FieldByName(FKeyFieldName);
  855. {$ENDIF}
  856.     try
  857.       DataSet.GetFieldList(FListFields, FListFieldName);
  858.     except
  859. {$IFDEF IVWIDE}
  860.       DatabaseErrorFmt(SFieldNotFound, [Self.Name, FListFieldName]);
  861. {$ENDIF}
  862.     end;
  863.     if FLookupMode then
  864.     begin
  865. {$IFDEF IVWIDE}
  866.       ResultField := GetFieldProperty(DataSet, Self, FDataField.LookupResultField);
  867. {$ELSE}
  868.       ResultField := DataSet.FieldByName(FDataField.LookupResultField);
  869. {$ENDIF}
  870.       if FListFields.IndexOf(ResultField) < 0 then
  871.         FListFields.Insert(0, ResultField);
  872.       FListField := ResultField;
  873.     end else
  874.     begin
  875.       if FListFields.Count = 0 then FListFields.Add(FKeyField);
  876.       if (FListFieldIndex >= 0) and (FListFieldIndex < FListFields.Count) then
  877.         FListField := FListFields[FListFieldIndex] else
  878.         FListField := FListFields[0];
  879.     end;
  880.     FListActive := True;
  881.   end;
  882. end;
  883.  
  884. procedure TIvDBLookupControl.ListLinkDataChanged;
  885. begin
  886. end;
  887.  
  888. function TIvDBLookupControl.LocateKey: Boolean;
  889. begin
  890.   Result := False;
  891.   try
  892.     if not VarIsNull(FKeyValue) and
  893.       FListLink.DataSet.Locate(FKeyFieldName, FKeyValue, []) then
  894.       Result := True;
  895.   except
  896.   end;
  897. end;
  898.  
  899. procedure TIvDBLookupControl.Notification(AComponent: TComponent;
  900.   Operation: TOperation);
  901. begin
  902.   inherited Notification(AComponent, Operation);
  903.   if Operation = opRemove then
  904.   begin
  905.     if (FDataLink <> nil) and (AComponent = DataSource) then DataSource := nil;
  906.     if (FListLink <> nil) and (AComponent = ListSource) then ListSource := nil;
  907.   end;
  908. end;
  909.  
  910. procedure TIvDBLookupControl.ProcessSearchKey(Key: Char);
  911. var
  912.   TickCount: Integer;
  913.   S: string;
  914. begin
  915.   if (FListField <> nil) and (FListField.FieldKind = fkData) and
  916.     (FListField.DataType = ftString) then
  917.     case Key of
  918.       #8, #27: FSearchText := '';
  919.       #32..#255:
  920.         if CanModify then
  921.         begin
  922.           TickCount := GetTickCount;
  923.           if TickCount - SearchTickCount > 2000 then FSearchText := '';
  924.           SearchTickCount := TickCount;
  925.           if Length(FSearchText) < 32 then
  926.           begin
  927.             S := FSearchText + Key;
  928.             if FListLink.DataSet.Locate(FListField.FieldName, S,
  929.               [loCaseInsensitive, loPartialKey]) then
  930.             begin
  931.               SelectKeyValue(FKeyField.Value);
  932.               FSearchText := S;
  933.             end;
  934.           end;
  935.         end;
  936.     end;
  937. end;
  938.  
  939. procedure TIvDBLookupControl.SelectKeyValue(const Value: Variant);
  940. begin
  941.   if FMasterField <> nil then
  942.   begin
  943.     if FDataLink.Edit then
  944.       FMasterField.Value := Value;
  945.   end else
  946.     SetKeyValue(Value);
  947.   Repaint;
  948.   Click;
  949. end;
  950.  
  951. procedure TIvDBLookupControl.SetDataFieldName(const Value: string);
  952. begin
  953.   if FDataFieldName <> Value then
  954.   begin
  955.     FDataFieldName := Value;
  956.     DataLinkActiveChanged;
  957.   end;
  958. end;
  959.  
  960. procedure TIvDBLookupControl.SetDataSource(Value: TDataSource);
  961. begin
  962.   FDataLink.DataSource := Value;
  963.   if Value <> nil then Value.FreeNotification(Self);
  964. end;
  965.  
  966. procedure TIvDBLookupControl.SetKeyFieldName(const Value: string);
  967. begin
  968.   CheckNotLookup;
  969.   if FKeyFieldName <> Value then
  970.   begin
  971.     FKeyFieldName := Value;
  972.     ListLinkActiveChanged;
  973.   end;
  974. end;
  975.  
  976. procedure TIvDBLookupControl.SetKeyValue(const Value: Variant);
  977. begin
  978.   if not VarEquals(FKeyValue, Value) then
  979.   begin
  980.     FKeyValue := Value;
  981.     KeyValueChanged;
  982.   end;
  983. end;
  984.  
  985. procedure TIvDBLookupControl.SetListFieldName(const Value: string);
  986. begin
  987.   if FListFieldName <> Value then
  988.   begin
  989.     FListFieldName := Value;
  990.     ListLinkActiveChanged;
  991.   end;
  992. end;
  993.  
  994. procedure TIvDBLookupControl.SetListSource(Value: TDataSource);
  995. begin
  996.   CheckNotLookup;
  997.   FListLink.DataSource := Value;
  998.   if Value <> nil then Value.FreeNotification(Self);
  999. end;
  1000.  
  1001. procedure TIvDBLookupControl.SetLookupMode(Value: Boolean);
  1002. begin
  1003.   if FLookupMode <> Value then
  1004.     if Value then
  1005.     begin
  1006. {$IFDEF IVWIDE}
  1007.       FMasterField := GetFieldProperty(FDataField.DataSet, Self, FDataField.KeyFields);
  1008. {$ELSE}
  1009.       FMasterField := FDataField.DataSet.FieldByName(FDataField.KeyFields);
  1010. {$ENDIF}
  1011.       FLookupSource.DataSet := FDataField.LookupDataSet;
  1012.       FKeyFieldName := FDataField.LookupKeyFields;
  1013.       FLookupMode := True;
  1014.       FListLink.DataSource := FLookupSource;
  1015.     end else
  1016.     begin
  1017.       FListLink.DataSource := nil;
  1018.       FLookupMode := False;
  1019.       FKeyFieldName := '';
  1020.       FLookupSource.DataSet := nil;
  1021.       FMasterField := FDataField;
  1022.     end;
  1023. end;
  1024.  
  1025. procedure TIvDBLookupControl.SetReadOnly(Value: Boolean);
  1026. begin
  1027.   FDataLink.ReadOnly := Value;
  1028. end;
  1029.  
  1030. procedure TIvDBLookupControl.WMGetDlgCode(var Message: TMessage);
  1031. begin
  1032.   Message.Result := DLGC_WANTARROWS or DLGC_WANTCHARS;
  1033. end;
  1034.  
  1035. procedure TIvDBLookupControl.WMKillFocus(var Message: TMessage);
  1036. begin
  1037.   FFocused := False;
  1038.   Inherited;
  1039.   Invalidate;
  1040. end;
  1041.  
  1042. procedure TIvDBLookupControl.WMSetFocus(var Message: TMessage);
  1043. begin
  1044.   FFocused := True;
  1045.   Inherited;
  1046.   Invalidate;
  1047. end;
  1048.  
  1049.  
  1050. { TIvDBLookupListBox }
  1051.  
  1052. constructor TIvDBLookupListBox.Create(owner: TComponent);
  1053. begin
  1054.   inherited Create(owner);
  1055.   ControlStyle := ControlStyle + [csDoubleClicks];
  1056.   Width := 121;
  1057.   FBorderStyle := bsSingle;
  1058.   RowCount := 7;
  1059. end;
  1060.  
  1061. procedure TIvDBLookupListBox.CreateParams(var Params: TCreateParams);
  1062. begin
  1063.   inherited CreateParams(Params);
  1064.   with Params do
  1065.     if FBorderStyle = bsSingle then
  1066.       if NewStyleControls and Ctl3D then
  1067.         ExStyle := ExStyle or WS_EX_CLIENTEDGE
  1068.       else
  1069.         Style := Style or WS_BORDER;
  1070. end;
  1071.  
  1072. procedure TIvDBLookupListBox.CreateWnd;
  1073. begin
  1074.   inherited CreateWnd;
  1075.   UpdateScrollBar;
  1076. end;
  1077.  
  1078. function TIvDBLookupListBox.GetKeyIndex: Integer;
  1079. var
  1080.   FieldValue: Variant;
  1081. begin
  1082.   if not VarIsNull(FKeyValue) then
  1083.     for Result := 0 to FRecordCount - 1 do
  1084.     begin
  1085.       FListLink.ActiveRecord := Result;
  1086.       FieldValue := FKeyField.Value;
  1087.       FListLink.ActiveRecord := FRecordIndex;
  1088.       if VarEquals(FieldValue, FKeyValue) then Exit;
  1089.     end;
  1090.   Result := -1;
  1091. end;
  1092.  
  1093. procedure TIvDBLookupListBox.KeyDown(var Key: Word; Shift: TShiftState);
  1094. var
  1095.   Delta, KeyIndex: Integer;
  1096. begin
  1097.   inherited KeyDown(Key, Shift);
  1098.   if CanModify then
  1099.   begin
  1100.     Delta := 0;
  1101.     case Key of
  1102.       VK_UP, VK_LEFT: Delta := -1;
  1103.       VK_DOWN, VK_RIGHT: Delta := 1;
  1104.       VK_PRIOR: Delta := 1 - FRowCount;
  1105.       VK_NEXT: Delta := FRowCount - 1;
  1106.       VK_HOME: Delta := -Maxint;
  1107.       VK_END: Delta := Maxint;
  1108.     end;
  1109.     if Delta <> 0 then
  1110.     begin
  1111.       FSearchText := '';
  1112.       if Delta = -Maxint then FListLink.DataSet.First else
  1113.         if Delta = Maxint then FListLink.DataSet.Last else
  1114.         begin
  1115.           KeyIndex := GetKeyIndex;
  1116.           if KeyIndex >= 0 then
  1117.             FListLink.DataSet.MoveBy(KeyIndex - FRecordIndex)
  1118.           else
  1119.           begin
  1120.             KeyValueChanged;
  1121.             Delta := 0;
  1122.           end;
  1123.           FListLink.DataSet.MoveBy(Delta);
  1124.         end;
  1125.       SelectCurrent;
  1126.     end;
  1127.   end;
  1128. end;
  1129.  
  1130. procedure TIvDBLookupListBox.KeyPress(var Key: Char);
  1131. begin
  1132.   inherited KeyPress(Key);
  1133.   ProcessSearchKey(Key);
  1134. end;
  1135.  
  1136. procedure TIvDBLookupListBox.KeyValueChanged;
  1137. begin
  1138.   if FListActive and not FLockPosition then
  1139.     if not LocateKey then FListLink.DataSet.First;
  1140.   if FListField <> nil then
  1141.     FSelectedItem := FListField.DisplayText else
  1142.     FSelectedItem := '';
  1143. end;
  1144.  
  1145. procedure TIvDBLookupListBox.ListLinkActiveChanged;
  1146. begin
  1147.   try
  1148.     inherited;
  1149.   finally
  1150.     if FListActive then KeyValueChanged else ListLinkDataChanged;
  1151.   end;
  1152. end;
  1153.  
  1154. procedure TIvDBLookupListBox.ListLinkDataChanged;
  1155. begin
  1156.   if FListActive then
  1157.   begin
  1158.     FRecordIndex := FListLink.ActiveRecord;
  1159.     FRecordCount := FListLink.RecordCount;
  1160.     FKeySelected := not VarIsNull(FKeyValue) or
  1161.       not FListLink.DataSet.BOF;
  1162.   end else
  1163.   begin
  1164.     FRecordIndex := 0;
  1165.     FRecordCount := 0;
  1166.     FKeySelected := False;
  1167.   end;
  1168.   if HandleAllocated then
  1169.   begin
  1170.     UpdateScrollBar;
  1171.     Invalidate;
  1172.   end;
  1173. end;
  1174.  
  1175. procedure TIvDBLookupListBox.MouseDown(Button: TMouseButton; Shift: TShiftState;
  1176.   X, Y: Integer);
  1177. begin
  1178.   if Button = mbLeft then
  1179.   begin
  1180.     FSearchText := '';
  1181.     if not FPopup then
  1182.     begin
  1183.       SetFocus;
  1184.       if not FFocused then Exit;
  1185.     end;
  1186.     if CanModify then
  1187.       if ssDouble in Shift then
  1188.       begin
  1189.         if FRecordIndex = Y div GetTextHeight then DblClick;
  1190.       end else
  1191.       begin
  1192.         MouseCapture := True;
  1193.         FTracking := True;
  1194.         SelectItemAt(X, Y);
  1195.       end;
  1196.   end;
  1197.   inherited MouseDown(Button, Shift, X, Y);
  1198. end;
  1199.  
  1200. procedure TIvDBLookupListBox.MouseMove(Shift: TShiftState; X, Y: Integer);
  1201. begin
  1202.   if FTracking then
  1203.   begin
  1204.     SelectItemAt(X, Y);
  1205.     FMousePos := Y;
  1206.     TimerScroll;
  1207.   end;
  1208.   inherited MouseMove(Shift, X, Y);
  1209. end;
  1210.  
  1211. procedure TIvDBLookupListBox.MouseUp(Button: TMouseButton; Shift: TShiftState;
  1212.   X, Y: Integer);
  1213. begin
  1214.   if FTracking then
  1215.   begin
  1216.     StopTracking;
  1217.     SelectItemAt(X, Y);
  1218.   end;
  1219.   inherited MouseUp(Button, Shift, X, Y);
  1220. end;
  1221.  
  1222. procedure TIvDBLookupListBox.Paint;
  1223. var
  1224.   I, J, W, X, TextWidth, TextHeight, LastFieldIndex: Integer;
  1225.   S: string;
  1226.   R: TRect;
  1227.   Selected: Boolean;
  1228.   Field: TField;
  1229. begin
  1230.   Canvas.Font := Font;
  1231.   TextWidth := Canvas.TextWidth('0');
  1232.   TextHeight := Canvas.TextHeight('0');
  1233.   LastFieldIndex := FListFields.Count - 1;
  1234.   if ColorToRGB(Color) <> ColorToRGB(clBtnFace) then
  1235.     Canvas.Pen.Color := clBtnFace else
  1236.     Canvas.Pen.Color := clBtnShadow;
  1237.   for I := 0 to FRowCount - 1 do
  1238.   begin
  1239.     Canvas.Font.Color := Font.Color;
  1240.     Canvas.Brush.Color := Color;
  1241.     Selected := not FKeySelected and (I = 0);
  1242.     R.Top := I * TextHeight;
  1243.     R.Bottom := R.Top + TextHeight;
  1244.     if I < FRecordCount then
  1245.     begin
  1246.       FListLink.ActiveRecord := I;
  1247.       if not VarIsNull(FKeyValue) and
  1248.         VarEquals(FKeyField.Value, FKeyValue) then
  1249.       begin
  1250.         Canvas.Font.Color := clHighlightText;
  1251.         Canvas.Brush.Color := clHighlight;
  1252.         Selected := True;
  1253.       end;
  1254.       R.Right := 0;
  1255.       for J := 0 to LastFieldIndex do
  1256.       begin
  1257.         Field := FListFields[J];
  1258.         if J < LastFieldIndex then
  1259.           W := Field.DisplayWidth * TextWidth + 4 else
  1260.           W := ClientWidth - R.Right;
  1261.         S := Field.DisplayText;
  1262.         X := 2;
  1263.         case Field.Alignment of
  1264.           taRightJustify: X := W - Canvas.TextWidth(S) - 3;
  1265.           taCenter: X := (W - Canvas.TextWidth(S)) div 2;
  1266.         end;
  1267.         R.Left := R.Right;
  1268.         R.Right := R.Right + W;
  1269.  
  1270.         { This has been changed from the standard VCL }
  1271.  
  1272.         {Canvas.TextRect(R, R.Left + X, R.Top, S);}
  1273.         PaintItem(Canvas, S, R, X, 0);
  1274.  
  1275.         if J < LastFieldIndex then
  1276.         begin
  1277.           Canvas.MoveTo(R.Right, R.Top);
  1278.           Canvas.LineTo(R.Right, R.Bottom);
  1279.           Inc(R.Right);
  1280.           if R.Right >= ClientWidth then Break;
  1281.         end;
  1282.       end;
  1283.     end;
  1284.     R.Left := 0;
  1285.     R.Right := ClientWidth;
  1286.     if I >= FRecordCount then Canvas.FillRect(R);
  1287.     if Selected and (FFocused or FPopup) then Canvas.DrawFocusRect(R);
  1288.   end;
  1289.   if FRecordCount <> 0 then FListLink.ActiveRecord := FRecordIndex;
  1290. end;
  1291.  
  1292. procedure TIvDBLookupListBox.SelectCurrent;
  1293. begin
  1294.   FLockPosition := True;
  1295.   try
  1296.     SelectKeyValue(FKeyField.Value);
  1297.   finally
  1298.     FLockPosition := False;
  1299.   end;
  1300. end;
  1301.  
  1302. procedure TIvDBLookupListBox.SelectItemAt(X, Y: Integer);
  1303. var
  1304.   Delta: Integer;
  1305. begin
  1306.   if Y < 0 then Y := 0;
  1307.   if Y >= ClientHeight then Y := ClientHeight - 1;
  1308.   Delta := Y div GetTextHeight - FRecordIndex;
  1309.   FListLink.DataSet.MoveBy(Delta);
  1310.   SelectCurrent;
  1311. end;
  1312.  
  1313. procedure TIvDBLookupListBox.SetBorderStyle(Value: TBorderStyle);
  1314. begin
  1315.   if FBorderStyle <> Value then
  1316.   begin
  1317.     FBorderStyle := Value;
  1318.     RecreateWnd;
  1319.     RowCount := RowCount;
  1320.   end;
  1321. end;
  1322.  
  1323. procedure TIvDBLookupListBox.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
  1324. var
  1325.   BorderSize, TextHeight, Rows: Integer;
  1326. begin
  1327.   BorderSize := GetBorderSize;
  1328.   TextHeight := GetTextHeight;
  1329.   Rows := (AHeight - BorderSize) div TextHeight;
  1330.   if Rows < 1 then Rows := 1;
  1331.   FRowCount := Rows;
  1332.   if FListLink.BufferCount <> Rows then
  1333.   begin
  1334.     FListLink.BufferCount := Rows;
  1335.     ListLinkDataChanged;
  1336.   end;
  1337.   inherited SetBounds(ALeft, ATop, AWidth, Rows * TextHeight + BorderSize);
  1338. end;
  1339.  
  1340. procedure TIvDBLookupListBox.SetRowCount(Value: Integer);
  1341. begin
  1342.   if Value < 1 then Value := 1;
  1343.   if Value > 100 then Value := 100;
  1344.   Height := Value * GetTextHeight + GetBorderSize;
  1345. end;
  1346.  
  1347. procedure TIvDBLookupListBox.StopTimer;
  1348. begin
  1349.   if FTimerActive then
  1350.   begin
  1351.     KillTimer(Handle, 1);
  1352.     FTimerActive := False;
  1353.   end;
  1354. end;
  1355.  
  1356. procedure TIvDBLookupListBox.StopTracking;
  1357. begin
  1358.   if FTracking then
  1359.   begin
  1360.     StopTimer;
  1361.     FTracking := False;
  1362.     MouseCapture := False;
  1363.   end;
  1364. end;
  1365.  
  1366. procedure TIvDBLookupListBox.TimerScroll;
  1367. var
  1368.   Delta, Distance, Interval: Integer;
  1369. begin
  1370.   Delta := 0;
  1371.   Distance := 0;
  1372.   if FMousePos < 0 then
  1373.   begin
  1374.     Delta := -1;
  1375.     Distance := -FMousePos;
  1376.   end;
  1377.   if FMousePos >= ClientHeight then
  1378.   begin
  1379.     Delta := 1;
  1380.     Distance := FMousePos - ClientHeight + 1;
  1381.   end;
  1382.   if Delta = 0 then StopTimer else
  1383.   begin
  1384.     if FListLink.DataSet.MoveBy(Delta) <> 0 then SelectCurrent;
  1385.     Interval := 200 - Distance * 15;
  1386.     if Interval < 0 then Interval := 0;
  1387.     SetTimer(Handle, 1, Interval, nil);
  1388.     FTimerActive := True;
  1389.   end;
  1390. end;
  1391.  
  1392. procedure TIvDBLookupListBox.UpdateScrollBar;
  1393. var
  1394.   Pos, Max: Integer;
  1395.   ScrollInfo: TScrollInfo;
  1396. begin
  1397.   Pos := 0;
  1398.   Max := 0;
  1399.   if FRecordCount = FRowCount then
  1400.   begin
  1401.     Max := 4;
  1402.     if not FListLink.DataSet.BOF then
  1403.       if not FListLink.DataSet.EOF then Pos := 2 else Pos := 4;
  1404.   end;
  1405.   ScrollInfo.cbSize := SizeOf(TScrollInfo);
  1406.   ScrollInfo.fMask := SIF_POS or SIF_RANGE;
  1407.   if not GetScrollInfo(Handle, SB_VERT, ScrollInfo) or
  1408.     (ScrollInfo.nPos <> Pos) or (ScrollInfo.nMax <> Max) then
  1409.   begin
  1410.     ScrollInfo.nMin := 0;
  1411.     ScrollInfo.nMax := Max;
  1412.     ScrollInfo.nPos := Pos;
  1413.     SetScrollInfo(Handle, SB_VERT, ScrollInfo, True);
  1414.   end;
  1415. end;
  1416.  
  1417. procedure TIvDBLookupListBox.CMCtl3DChanged(var Message: TMessage);
  1418. begin
  1419.   if NewStyleControls and (FBorderStyle = bsSingle) then
  1420.   begin
  1421.     RecreateWnd;
  1422.     RowCount := RowCount;
  1423.   end;
  1424.   inherited;
  1425. end;
  1426.  
  1427. procedure TIvDBLookupListBox.CMFontChanged(var Message: TMessage);
  1428. begin
  1429.   inherited;
  1430.   Height := Height;
  1431. end;
  1432.  
  1433. procedure TIvDBLookupListBox.WMCancelMode(var Message: TMessage);
  1434. begin
  1435.   StopTracking;
  1436.   inherited;
  1437. end;
  1438.  
  1439. procedure TIvDBLookupListBox.WMTimer(var Message: TMessage);
  1440. begin
  1441.   TimerScroll;
  1442. end;
  1443.  
  1444. procedure TIvDBLookupListBox.WMVScroll(var Message: TWMVScroll);
  1445. begin
  1446.   FSearchText := '';
  1447.   with Message, FListLink.DataSet do
  1448.     case ScrollCode of
  1449.       SB_LINEUP: MoveBy(-FRecordIndex - 1);
  1450.       SB_LINEDOWN: MoveBy(FRecordCount - FRecordIndex);
  1451.       SB_PAGEUP: MoveBy(-FRecordIndex - FRecordCount + 1);
  1452.       SB_PAGEDOWN: MoveBy(FRecordCount - FRecordIndex + FRecordCount - 2);
  1453.       SB_THUMBPOSITION:
  1454.         begin
  1455.           case Pos of
  1456.             0: First;
  1457.             1: MoveBy(-FRecordIndex - FRecordCount + 1);
  1458.             2: Exit;
  1459.             3: MoveBy(FRecordCount - FRecordIndex + FRecordCount - 2);
  1460.             4: Last;
  1461.           end;
  1462.         end;
  1463.       SB_BOTTOM: Last;
  1464.       SB_TOP: First;
  1465.     end;
  1466. end;
  1467.  
  1468.  
  1469. { TIvPopupDataList }
  1470.  
  1471. constructor TIvPopupDataList.Create(AOwner: TComponent);
  1472. begin
  1473.   inherited Create(AOwner);
  1474.   ControlStyle := ControlStyle + [csNoDesignVisible, csReplicatable];
  1475.   FPopup := True;
  1476. end;
  1477.  
  1478. procedure TIvPopupDataList.CreateParams(var Params: TCreateParams);
  1479. begin
  1480.   inherited CreateParams(Params);
  1481.   with Params do
  1482.   begin
  1483.     Style := WS_POPUP or WS_BORDER;
  1484.     ExStyle := WS_EX_TOOLWINDOW;
  1485.     WindowClass.Style := CS_SAVEBITS;
  1486.   end;
  1487. end;
  1488.  
  1489. procedure TIvPopupDataList.WMMouseActivate(var Message: TMessage);
  1490. begin
  1491.   Message.Result := MA_NOACTIVATE;
  1492. end;
  1493.  
  1494.  
  1495. { TIvDBLookupComboBox }
  1496.  
  1497. constructor TIvDBLookupComboBox.Create(AOwner: TComponent);
  1498. begin
  1499.   inherited Create(AOwner);
  1500.   ControlStyle := ControlStyle + [csReplicatable];
  1501.   Width := 145;
  1502.   Height := 0;
  1503.   FDataList := TIvPopupDataList.Create(Self);
  1504.   FDataList.Visible := False;
  1505.   FDataList.Parent := Self;
  1506.   FDataList.OnMouseUp := ListMouseUp;
  1507.   FButtonWidth := GetSystemMetrics(SM_CXVSCROLL);
  1508.   FDropDownRows := 7;
  1509. end;
  1510.  
  1511. procedure TIvDBLookupComboBox.CloseUp(Accept: Boolean);
  1512. var
  1513.   ListValue: Variant;
  1514. begin
  1515.   if FListVisible then
  1516.   begin
  1517.     if GetCapture <> 0 then SendMessage(GetCapture, WM_CANCELMODE, 0, 0);
  1518.     ListValue := FDataList.KeyValue;
  1519.     SetWindowPos(FDataList.Handle, 0, 0, 0, 0, 0, SWP_NOZORDER or
  1520.       SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE or SWP_HIDEWINDOW);
  1521.     FListVisible := False;
  1522.     FDataList.ListSource := nil;
  1523.     Invalidate;
  1524.     FSearchText := '';
  1525.     if Accept and CanModify then SelectKeyValue(ListValue);
  1526.     if Assigned(FOnCloseUp) then FOnCloseUp(Self);
  1527.   end;
  1528. end;
  1529.  
  1530. procedure TIvDBLookupComboBox.CreateParams(var Params: TCreateParams);
  1531. begin
  1532.   inherited CreateParams(Params);
  1533.   with Params do
  1534.     if NewStyleControls and Ctl3D then
  1535.       ExStyle := ExStyle or WS_EX_CLIENTEDGE
  1536.     else
  1537.       Style := Style or WS_BORDER;
  1538. end;
  1539.  
  1540. procedure TIvDBLookupComboBox.DropDown;
  1541. var
  1542.   P: TPoint;
  1543.   I, Y: Integer;
  1544.   S: string;
  1545. begin
  1546.   if not FListVisible and FListActive then
  1547.   begin
  1548.     if Assigned(FOnDropDown) then FOnDropDown(Self);
  1549.     FDataList.Color := Color;
  1550.     FDataList.Font := Font;
  1551.     if FDropDownWidth > 0 then
  1552.       FDataList.Width := FDropDownWidth else
  1553.       FDataList.Width := Width;
  1554.     FDataList.ReadOnly := not CanModify;
  1555.     FDataList.RowCount := FDropDownRows;
  1556.     FDataList.KeyField := FKeyFieldName;
  1557.     for I := 0 to FListFields.Count - 1 do
  1558.       S := S + TField(FListFields[I]).FieldName + ';';
  1559.     FDataList.ListField := S;
  1560.     FDataList.ListFieldIndex := FListFields.IndexOf(FListField);
  1561.     FDataList.ListSource := FListLink.DataSource;
  1562.     FDataList.KeyValue := KeyValue;
  1563.     P := Parent.ClientToScreen(Point(Left, Top));
  1564.     Y := P.Y + Height;
  1565.     if Y + FDataList.Height > Screen.Height then Y := P.Y - FDataList.Height;
  1566.     case FDropDownAlign of
  1567.       daRight: Dec(P.X, FDataList.Width - Width);
  1568.       daCenter: Dec(P.X, (FDataList.Width - Width) div 2);
  1569.     end;
  1570.     SetWindowPos(FDataList.Handle, HWND_TOP, P.X, Y, 0, 0,
  1571.       SWP_NOSIZE or SWP_NOACTIVATE or SWP_SHOWWINDOW);
  1572.     FListVisible := True;
  1573.     Repaint;
  1574.   end;
  1575. end;
  1576.  
  1577. procedure TIvDBLookupComboBox.KeyDown(var Key: Word; Shift: TShiftState);
  1578. var
  1579.   Delta: Integer;
  1580. begin
  1581.   inherited KeyDown(Key, Shift);
  1582.   if FListActive and ((Key = VK_UP) or (Key = VK_DOWN)) then
  1583.     if ssAlt in Shift then
  1584.     begin
  1585.       if FListVisible then CloseUp(True) else DropDown;
  1586.       Key := 0;
  1587.     end else
  1588.       if not FListVisible then
  1589.       begin
  1590.         if not LocateKey then
  1591.           FListLink.DataSet.First
  1592.         else
  1593.         begin
  1594.           if Key = VK_UP then Delta := -1 else Delta := 1;
  1595.           FListLink.DataSet.MoveBy(Delta);
  1596.         end;
  1597.         SelectKeyValue(FKeyField.Value);
  1598.         Key := 0;
  1599.       end;
  1600.   if (Key <> 0) and FListVisible then FDataList.KeyDown(Key, Shift);
  1601. end;
  1602.  
  1603. procedure TIvDBLookupComboBox.KeyPress(var Key: Char);
  1604. begin
  1605.   inherited KeyPress(Key);
  1606.   if FListVisible then
  1607.     if Key in [#13, #27] then
  1608.       CloseUp(Key = #13)
  1609.     else
  1610.       FDataList.KeyPress(Key)
  1611.   else
  1612.     ProcessSearchKey(Key);
  1613. end;
  1614.  
  1615. procedure TIvDBLookupComboBox.KeyValueChanged;
  1616. begin
  1617.   if FLookupMode then
  1618.   begin
  1619.     FText := FDataField.DisplayText;
  1620.     FAlignment := FDataField.Alignment;
  1621.   end else
  1622.   if FListActive and LocateKey then
  1623.   begin
  1624.     FText := FListField.DisplayText;
  1625.     FAlignment := FListField.Alignment;
  1626.   end else
  1627.   begin
  1628.     FText := '';
  1629.     FAlignment := taLeftJustify;
  1630.   end;
  1631.   Invalidate;
  1632. end;
  1633.  
  1634. procedure TIvDBLookupComboBox.ListLinkActiveChanged;
  1635. begin
  1636.   inherited;
  1637.   KeyValueChanged;
  1638. end;
  1639.  
  1640. procedure TIvDBLookupComboBox.ListMouseUp(Sender: TObject; Button: TMouseButton;
  1641.   Shift: TShiftState; X, Y: Integer);
  1642. begin
  1643.   if Button = mbLeft then
  1644.     CloseUp(PtInRect(FDataList.ClientRect, Point(X, Y)));
  1645. end;
  1646.  
  1647. procedure TIvDBLookupComboBox.MouseDown(Button: TMouseButton; Shift: TShiftState;
  1648.   X, Y: Integer);
  1649. begin
  1650.   if Button = mbLeft then
  1651.   begin
  1652.     SetFocus;
  1653.     if not FFocused then Exit;
  1654.     if FListVisible then CloseUp(False) else
  1655.       if FListActive then
  1656.       begin
  1657.         MouseCapture := True;
  1658.         FTracking := True;
  1659.         TrackButton(X, Y);
  1660.         DropDown;
  1661.       end;
  1662.   end;
  1663.   inherited MouseDown(Button, Shift, X, Y);
  1664. end;
  1665.  
  1666. procedure TIvDBLookupComboBox.MouseMove(Shift: TShiftState; X, Y: Integer);
  1667. var
  1668.   ListPos: TPoint;
  1669.   MousePos: TSmallPoint;
  1670. begin
  1671.   if FTracking then
  1672.   begin
  1673.     TrackButton(X, Y);
  1674.     if FListVisible then
  1675.     begin
  1676.       ListPos := FDataList.ScreenToClient(ClientToScreen(Point(X, Y)));
  1677.       if PtInRect(FDataList.ClientRect, ListPos) then
  1678.       begin
  1679.         StopTracking;
  1680.         MousePos := PointToSmallPoint(ListPos);
  1681.         SendMessage(FDataList.Handle, WM_LBUTTONDOWN, 0, Integer(MousePos));
  1682.         Exit;
  1683.       end;
  1684.     end;
  1685.   end;
  1686.   inherited MouseMove(Shift, X, Y);
  1687. end;
  1688.  
  1689. procedure TIvDBLookupComboBox.MouseUp(Button: TMouseButton; Shift: TShiftState;
  1690.   X, Y: Integer);
  1691. begin
  1692.   StopTracking;
  1693.   inherited MouseUp(Button, Shift, X, Y);
  1694. end;
  1695.  
  1696. procedure TIvDBLookupComboBox.Paint;
  1697. var
  1698.   W, X, Flags: Integer;
  1699.   Text: string;
  1700.   Alignment: TAlignment;
  1701.   Selected: Boolean;
  1702.   R: TRect;
  1703. begin
  1704.   Canvas.Font := Font;
  1705.   Canvas.Brush.Color := Color;
  1706.   Selected := FFocused and not FListVisible and
  1707.     not (csPaintCopy in ControlState);
  1708.   if Selected then
  1709.   begin
  1710.     Canvas.Font.Color := clHighlightText;
  1711.     Canvas.Brush.Color := clHighlight;
  1712.   end;
  1713.   if (csPaintCopy in ControlState) and (FDataField <> nil) then
  1714.   begin
  1715.     Text := FDataField.DisplayText;
  1716.     Alignment := FDataField.Alignment;
  1717.   end else
  1718.   begin
  1719.     Text := FText;
  1720.     Alignment := FAlignment;
  1721.   end;
  1722.   W := ClientWidth - FButtonWidth;
  1723.   X := 2;
  1724.   case Alignment of
  1725.     taRightJustify: X := W - Canvas.TextWidth(Text) - 3;
  1726.     taCenter: X := (W - Canvas.TextWidth(Text)) div 2;
  1727.   end;
  1728.   SetRect(R, 1, 1, W - 1, ClientHeight - 1);
  1729.  
  1730.   { This has been changed from the standard VCL }
  1731.  
  1732.   {Canvas.TextRect(R, X, 2, Text);}
  1733.   PaintItem(Canvas, Text, R, X - 1, 1);
  1734.  
  1735.   if Selected then Canvas.DrawFocusRect(R);
  1736.   SetRect(R, W, 0, ClientWidth, ClientHeight);
  1737.   if not FListActive then
  1738.     Flags := DFCS_SCROLLCOMBOBOX or DFCS_INACTIVE
  1739.   else if FPressed then
  1740.     Flags := DFCS_SCROLLCOMBOBOX or DFCS_FLAT or DFCS_PUSHED
  1741.   else
  1742.     Flags := DFCS_SCROLLCOMBOBOX;
  1743.   DrawFrameControl(Canvas.Handle, R, DFC_SCROLL, Flags);
  1744. end;
  1745.  
  1746. procedure TIvDBLookupComboBox.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
  1747. begin
  1748.   inherited SetBounds(ALeft, ATop, AWidth, GetTextHeight + GetBorderSize + 4);
  1749. end;
  1750.  
  1751. procedure TIvDBLookupComboBox.StopTracking;
  1752. begin
  1753.   if FTracking then
  1754.   begin
  1755.     TrackButton(-1, -1);
  1756.     FTracking := False;
  1757.     MouseCapture := False;
  1758.   end;
  1759. end;
  1760.  
  1761. procedure TIvDBLookupComboBox.TrackButton(X, Y: Integer);
  1762. var
  1763.   NewState: Boolean;
  1764. begin
  1765.   NewState := PtInRect(Rect(ClientWidth - FButtonWidth, 0, ClientWidth,
  1766.     ClientHeight), Point(X, Y));
  1767.   if FPressed <> NewState then
  1768.   begin
  1769.     FPressed := NewState;
  1770.     Repaint;
  1771.   end;
  1772. end;
  1773.  
  1774. procedure TIvDBLookupComboBox.CMCancelMode(var Message: TCMCancelMode);
  1775. begin
  1776.   if (Message.Sender <> Self) and (Message.Sender <> FDataList) then
  1777.     CloseUp(False);
  1778. end;
  1779.  
  1780. procedure TIvDBLookupComboBox.CMCtl3DChanged(var Message: TMessage);
  1781. begin
  1782.   if NewStyleControls then
  1783.   begin
  1784.     RecreateWnd;
  1785.     Height := 0;
  1786.   end;
  1787.   inherited;
  1788. end;
  1789.  
  1790. procedure TIvDBLookupComboBox.CMFontChanged(var Message: TMessage);
  1791. begin
  1792.   inherited;
  1793.   Height := 0;
  1794. end;
  1795.  
  1796. procedure TIvDBLookupComboBox.CMGetDataLink(var Message: TMessage);
  1797. begin
  1798.   Message.Result := Integer(FDataLink);
  1799. end;
  1800.  
  1801. procedure TIvDBLookupComboBox.WMCancelMode(var Message: TMessage);
  1802. begin
  1803.   StopTracking;
  1804.   inherited;
  1805. end;
  1806.  
  1807. procedure TIvDBLookupComboBox.WMKillFocus(var Message: TWMKillFocus);
  1808. begin
  1809.   inherited;
  1810.   CloseUp(False);
  1811. end;
  1812. {$ENDIF}
  1813. {$ENDIF}
  1814.  
  1815. end.
  1816.